home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / wb1a1.lha / wb / ent.scm < prev    next >
Encoding:
Text File  |  1993-06-29  |  29.7 KB  |  859 lines
  1. ; Wb-tree File Based Associative String Data Base System.
  2. ; Copyright (c) 1991, 1992, 1993 Holland Mark Martin
  3. ;
  4. ;Permission to use, copy, modify, and distribute this software and its
  5. ;documentation for educational, research, and non-profit purposes and
  6. ;without fee is hereby granted, provided that the above copyright
  7. ;notice appear in all copies and that both that copyright notice and
  8. ;this permission notice appear in supporting documentation, and that
  9. ;the name of Holland Mark Martin not be used in advertising or
  10. ;publicity pertaining to distribution of the software without specific,
  11. ;written prior consent in each case.  Permission to incorporate this
  12. ;software into commercial products can be obtained from Jonathan
  13. ;Finger, Holland Mark Martin, 174 Middlesex Turnpike, Burlington, MA,
  14. ;01803-4467, USA.  Holland Mark Martin makes no representations about
  15. ;the suitability or correctness of this software for any purpose.  It
  16. ;is provided "as is" without express or implied warranty.  Holland Mark
  17. ;Martin is under no obligation to provide any services, by way of
  18. ;maintenance, update, or otherwise.
  19.  
  20. (require (in-vicinity (program-vicinity) "sys"))
  21.  
  22. ;;;; tables
  23.  
  24. (define lck-tab #f)
  25. (define buk-tab #f)
  26. (define ent-tab #f)
  27. (define num-ents-ct 0)
  28. (define num-buks 0)
  29. (define blk-size 0)
  30. (define empty-blk #f)
  31. (define empty-blk-lck #f)
  32.  
  33. (define cache-ent-enable #t)
  34.  
  35. ;;;; DATABASE LEVEL OPERATIONS
  36.  
  37. ;;; This can be bummed to write less than the full BSIZ if we know
  38. ;;; what the disk sector size is.
  39. ;; fixed order check in ent-write
  40.  
  41. (define (ent-write ent)
  42.   (define seg (ENT-SEG ent))
  43.   (define blk (ENT-BLK ent))
  44. ;; (fprintf diagout "Writing block %d:%ld\\n" seg (ENT-ID ent))
  45.   (if (not (BLK-TYP? blk SEQ-TYP))
  46.       (check-key-order! blk))
  47.   (BLK-SET-TIME! blk (get-universal-time))
  48.   (cond ((= -2 (SEG-FLC-LEN seg))
  49.      (fprintf diagout
  50.           ">>>>ERROR<<<< ent-write on read only segment %d?\\n" seg)
  51.      #f)
  52.     ((blk-write (SEG-PORT seg) (ENT-BLK ent) (SEG-BSIZ seg) (ENT-ID ent))
  53.      (ENT-SET-DTY! ent #f)
  54.      #t)
  55.     (else
  56.      (ENT-SET-DTY! ent #t)
  57.      #f)))
  58.  
  59. ;;; FLUSHING needs to be proportional to time (to put some limit on how long
  60. ;;; things are left unwritten) plus write-activity.
  61. ;;; NOTE: While flushing a buffer, get accpend access to it (to prevent surprise mods)
  62. ;;; 3/93 if maxnum argument is 0, will return nonzero if there are
  63. ;;; entries to be flushed within numbuks buckets. 
  64. (define flush-buk-cntr #f)
  65. (define flush-buk-lck #f)
  66.  
  67. (define (flush-some-buks numbuks maxnum)
  68.   (define numflushed 0)
  69.   (and
  70.    (try-lck flush-buk-lck)
  71.    (do ((i numbuks (- i 1)))
  72.        ((or (zero? i) (> numflushed maxnum))
  73.     (if (zero? maxnum)
  74.         (set! flush-buk-cntr (remainder (+ -1 flush-buk-cntr) num-buks)))
  75.     (unlck! flush-buk-lck)
  76.     numflushed)
  77.      (set! flush-buk-cntr (remainder (+ 1 flush-buk-cntr) num-buks))
  78.      (and (GET-BUK-LCK 0 flush-buk-cntr)
  79.       (do ((ent (GET-BUK 0 flush-buk-cntr) (ENT-NEXT ent)))
  80.           ((not ent) (REL-BUK! 0 flush-buk-cntr))
  81.         (if (and (ENT-DTY? ent) (not (ENT-ACC ent)))
  82.         ;;TBD- when multiple readers are allowed we can use
  83.         ;;read access instead of accpend access to exclude writers.
  84.         ;;trust me. you need this.
  85.         (cond ((not (zero? maxnum))
  86.                (ENT-SET-ACC! ent accpend)
  87.                (REL-BUK! 0 flush-buk-cntr)
  88.                (ent-write ent)
  89.                (GET-BUK-WAIT 0 flush-buk-cntr)
  90.                (ENT-SET-ACC! ent #f)
  91.                (set! flush-ct (+ flush-ct 1))))
  92.         (set! numflushed (+ numflushed 1))))))))
  93.  
  94. ;;; release-ent! gives up all claim to ent, which is expected to be of
  95. ;;; type acctype
  96. ;; fixed warning about dirty dirs -- twice
  97. ;; fixed dirty-block writer in UPDATE-ACCESS!
  98.  
  99. (define (release-ent! ent acctype)
  100.   (define blknum (ENT-ID ent))
  101.   (define seg (ENT-SEG ent))
  102.   (define buk #f)
  103. ;;;  (fprintf diagout "release-ent! %d:%ld %d\\n" seg blknum acctype)
  104.   (set! buk (GET-BUK-WAIT seg blknum))
  105. ;;;(if (not (BLK-TYP? (ENT-BLK ent) SEQ-TYP))
  106. ;;;    (check-key-order! (ENT-BLK ent)))
  107.   (if (and acctype (not (eq? (ENT-ACC ent) acctype)))
  108.       ;;TBD- clean this error up
  109.       (fprintf
  110.        diagout
  111.        ">>>>ERROR<<<< RELEASE-ENT!: unexpected acctype of %d:%ld is %d not %d\\n"
  112.        seg blknum (ENT-ACC ent) acctype))
  113.   (cond ((not acctype))
  114.     ((not (ENT-DTY? ent)))
  115.     ((BLK-TYP? (ENT-BLK ent) DIR-TYP)
  116.      (fprintf diagout ">>>>WARNING<<<< Directory block %d:%ld dirty at RELEASE-ENT! \\n" seg blknum)
  117.      (set! dir-dty-ct (+ 1 dir-dty-ct)))
  118.     ((BLK-TYP? (ENT-BLK ent) SEQ-TYP)
  119.      (REL-BUK! seg blknum)
  120.      (ent-write ent)
  121.      (set! buk (GET-BUK-WAIT seg blknum))))
  122.   (if acctype (ENT-SET-ACC! ent #f))
  123.   (cond ((<= (ENT-REF ent) 0)
  124.      (ENT-SET-REF! ent 0)
  125.      (fprintf diagout ">>>>ERROR<<<< REF count below 0 in %d:%ld\\n"
  126.           seg blknum))
  127.     (else
  128.      (ENT-SET-REF! ent (- (ENT-REF ent) 1))))
  129.   (cond ((negative? seg)
  130.      (splice-out-ent! seg blknum buk ent))
  131.     (else
  132.      (ENT-SET-AGE! ent (+ (if (ENT-DTY? ent) 5 0)
  133.                   (* 5 (+ 6 (- LEAF (BLK-LEVEL (ENT-BLK ent)))))))))
  134.   (REL-BUK! seg blknum))
  135.  
  136. (define (ent-update-access ent old-acctype new-acctype)
  137. ;  (fprintf diagout "ent-update-access %d:%ld %d %d\\n"
  138. ;       (ENT-SEG ent) (ENT-ID ent) old-acctype new-acctype)
  139.   (GET-BUK-WAIT (ENT-SEG ent) (ENT-ID ent))
  140.   (cond ((not (eq? (ENT-ACC ent) old-acctype))
  141.      (REL-BUK! (ENT-SEG ent) (ENT-ID ent))
  142.      (fprintf diagout ">>>>ERROR<<<< unexpected access type on %d:%ld %d\\n"
  143.           (ENT-SEG ent) (ENT-ID ent) (ENT-ACC ent))))
  144.   (cond ((not old-acctype))
  145.     ((not (ENT-DTY? ent)))
  146.     ((BLK-TYP? (ENT-BLK ent) SEQ-TYP)
  147.      (REL-BUK! (ENT-SEG ent) (ENT-ID ent))
  148.      (ent-write ent)
  149.      (GET-BUK-WAIT (ENT-SEG ent) (ENT-ID ent)))
  150.     ((BLK-TYP? (ENT-BLK ent) DIR-TYP)
  151.      (fprintf diagout ">>>>WARNING<<<< Directory block %d:%ld dirty at ENT-UPD-ACCESS! \\n" (ENT-SEG ent) (ENT-ID ent))
  152.      (set! dir-dty-ct (+ 1 dir-dty-ct)))
  153.     )
  154.   (ENT-SET-ACC! ent new-acctype)
  155.   (REL-BUK! (ENT-SEG ent) (ENT-ID ent))
  156.   (and ent #t))
  157.  
  158. ;;; ENT-FREE-LIST stuff -----------------------------------------------------------
  159.  
  160. (define free-buk-cntr #f)
  161. (define free-ent-lck #f)
  162. (define free-ents #f)
  163.  
  164. (define (get-free-free-ent)
  165.   (lck! free-ent-lck)
  166.   (and free-ents
  167.        (let ((free-ent free-ents))
  168.      (set! free-ents (ENT-NEXT free-ents))
  169.      (unlck! free-ent-lck)
  170.      free-ent)))
  171.  
  172. ;; this version assumes the caller has already locked the bucket
  173. ;; BUK containing ENT
  174.  
  175. (define (splice-out-ent! seg blk-num buk ent)
  176.   (do ((bent buk (ENT-NEXT bent))
  177.        (lastent #f bent))
  178.       ((or (not bent) (eq? bent ent))
  179.        (cond
  180.     (bent (if lastent
  181.           (ENT-SET-NEXT! lastent (ENT-NEXT bent))
  182.           (SET-BUK! seg blk-num (ENT-NEXT bent)))
  183. ;;;          (fprintf diagout "SPLICING OUT buk=%d:%ld ent=%d:%ld last=%d\\n"
  184. ;;;               seg blk-num (ENT-SEG bent) (ENT-ID bent)
  185. ;;;               (if lastent (ENT-ID lastent) -1))
  186.           (recycle-ent! bent))
  187.     (else (fprintf diagout ">>>>WARNING<<<< couldn't splice-out-ent! %d:%ld\\n"
  188.                seg blk-num))))))
  189.  
  190. (define (recycle-ent! ent)
  191.   (ENT-SET-DTY! ent #f)
  192.   (ENT-SET-PUS! ent 0)
  193.   (ENT-SET-SEG! ent -1)
  194.   (ENT-SET-ID! ent -1)
  195.   (lck! free-ent-lck)
  196.   (ENT-SET-REF! ent 0)
  197.   (ENT-SET-ACC! ent #f)
  198.   (ENT-SET-NEXT! ent free-ents)
  199.   (set! free-ents ent)
  200.   (unlck! free-ent-lck))
  201.  
  202. ;;; SELECT-IDLE-ENT selects a candidate entry for reuse.  caller needs to call
  203. ;;; RECLAIM-ENT next to splice entry out of its bucket.
  204. ;;; NOTE: when called, bucket (lseg lblk-num) is lcked.
  205. ;;; The target bucket is assumed unlocked if lseg < 0.
  206. ;;; (GET-ENT calls this with the bucket locked to prevent someone else from
  207. ;;; getting another entry for the same block.)
  208.  
  209. (define (select-idle-ent lseg lblk-num)
  210. ;;;  (fprintf diagout "select-idle-ent %d:%ld\\n" lseg lblk-num)
  211.   (let ((oldest-ent #f)
  212.     (num-scan (max (min num-buks 10) (quotient num-buks 20)))
  213.     (free-base free-buk-cntr))
  214. ;;;  (fprintf diagout "select-idle-ent: aging %d buks\\n" num-scan)
  215.     (set! free-buk-cntr (remainder (+ num-scan free-buk-cntr) num-buks))    
  216.     (unlck! free-ent-lck)
  217.     (do ((i 0 (+ i 1)))
  218.     ((or (and (> i num-scan) oldest-ent) (> i num-buks))
  219. ;;; This searches num-buks/20 buckets, or some minimum number like 10.
  220. ;;;           (fprintf diagout "reclaiming ent= %d:%ld age=%d\\n"
  221. ;;;            (if oldest-ent (ENT-SEG oldest-ent) -1)
  222. ;;;            (if oldest-ent (ENT-ID oldest-ent) -1)
  223. ;;;            (if oldest-ent (ENT-AGE oldest-ent) -999))
  224.      (if (> i num-buks)
  225.          (fprintf diagout ">>>>ERROR<<<< No free ents\\n"))
  226.      oldest-ent)
  227.       (let* ((free-num (remainder (+ free-base i) num-buks))
  228.          (dont-lock? (if (negative? lseg) #f
  229.                  (= free-num (HASH2INT lseg lblk-num)))))
  230.     (and
  231.      (or dont-lock? (GET-BUK-LCK 0 free-num))
  232.      (do ((ent (GET-BUK 0 free-num) (ENT-NEXT ent)))
  233.          ((not ent) (or dont-lock? (REL-BUK! 0 free-num)))
  234. ;;;           (fprintf diagout "select-idle-ent i= %d oldest-ent= %d:%ld ent= %d:%ld\\n"
  235. ;;;            i (if oldest-ent (ENT-SEG oldest-ent) 0)
  236. ;;;            (if oldest-ent (ENT-ID oldest-ent) -1)
  237. ;;;            (ENT-SEG ent) (ENT-ID ent))
  238.        (if (zero? (ENT-REF ent))
  239.            (begin
  240.          (ENT-SET-AGE! ent (+ (if (ENT-DTY? ent) 1 2) (ENT-AGE ent)))
  241.          (and (not (ENT-ACC ent)) ;this is redundant but robust
  242.               (or (not oldest-ent) (> (ENT-AGE ent) (ENT-AGE oldest-ent)))
  243.               (set! oldest-ent ent))))))))))
  244.  
  245. ;;; RECLAIM-ENT unlinks ENT from its bucket if its not in use.
  246. ;;; It writes out the entry-s block if it's dirty
  247. ;;; RECLAIM-ENT has 3 cases
  248. ;;;  (a) ENT is in use -- LSEG is unlocked, NIL is returned
  249. ;;;  (b) ENT is clean -- ENT is unlinked and returned
  250. ;;;  (c) ENT is DIRTY -- ENT is written, unlinked, and reclaimed (put on
  251. ;;;            free lsit); LSEG is UNLOCKED, NIL is returned.
  252. ;;;    possible optimization in case (c): if LSEG = -,
  253. ;;;    ENT could be written, unlinked, and returned (like (b))
  254.  
  255. (define (reclaim-ent ent lseg lblk-num)
  256.   (let* ((seg (ENT-SEG ent))
  257.      (blk-num (ENT-ID ent))
  258.      (segs-equal? (and (not (negative? lseg))
  259.                (SAME-BUK? lseg lblk-num seg blk-num)))
  260.      (buk (if segs-equal?
  261.            (GET-BUK seg blk-num)
  262.            (GET-BUK-WAIT seg blk-num))))
  263.     (cond ((or (not (zero? (ENT-REF ent))) ; ENT in use?
  264.            (ENT-ACC ent))
  265.        (REL-BUK! seg blk-num)
  266.        (or segs-equal? (negative? lseg) (REL-BUK! lseg lblk-num))
  267.        (fprintf diagout ">>>>WARNING<<<< reclaim-ent: couldn't splice-out-ent %d:%ld\\n"
  268.             lseg lblk-num)
  269.        #f)
  270.       (else
  271.        (do ((bent buk (ENT-NEXT bent))
  272.         (lastent #f bent))
  273.            ((or (not bent) (eq? ent bent))
  274.         (cond
  275.          ((not bent)
  276.           (REL-BUK! seg blk-num)
  277.           (or segs-equal? (negative? lseg) (REL-BUK! lseg lblk-num))
  278.           (fprintf diagout ">>>>ERROR<<<< reclaim-ent: couldn't find ent in bucket %d:%ld l=%d:%ld\\n"
  279.                seg blk-num lseg lblk-num)
  280.           #f)
  281.          ;;ent and bent are now the same
  282.          ((not (ENT-DTY? ent))
  283.           (if lastent        ; unlink
  284.               (ENT-SET-NEXT! lastent (ENT-NEXT ent))
  285.               (SET-BUK! seg blk-num (ENT-NEXT ent)))
  286.           (ENT-SET-NEXT! ent #f) ;for safety
  287.           (or segs-equal? (REL-BUK! seg blk-num))
  288. ;;;          (fprintf diagout "reclaim-ent CLEAN: ent= %d:%ld l=%d:%ld seq=%d\\n"
  289. ;;;               seg blk-num lseg lblk-num (if segs-equal? 1 0))
  290.           ent)
  291.          (else            ;ent is DTY
  292.           (ENT-SET-ACC! ent accpend)
  293.           (REL-BUK! seg blk-num)
  294.           (or segs-equal? (negative? lseg) (REL-BUK! lseg lblk-num))
  295.           (ent-write ent)
  296.           (set! buk (GET-BUK-WAIT seg blk-num))
  297.           (ENT-SET-ACC! ent #f)
  298.              ; if (negative? lseg) then should return it directly
  299.           (splice-out-ent! seg blk-num buk ent)
  300.           (REL-BUK! seg blk-num)
  301. ;;;          (fprintf diagout "reclaim-ent DIRTY: ent= %d:%ld l=%d:%ld seq=%d\\n"
  302. ;;;               seg blk-num lseg lblk-num (if segs-equal? 1 0))
  303.           #f)))))
  304.       )))
  305.  
  306. ;; TRY-GET-FREE-ENT either returns a free ent OR unlocks (lseg lblk-num)
  307.  
  308. (define (try-get-free-ent lseg lblk-num)
  309.   (define ent (get-free-free-ent))
  310.   (cond ((not ent)
  311.      (set! ent (select-idle-ent lseg lblk-num))
  312.      (if ent (set! ent (reclaim-ent ent lseg lblk-num))
  313.          (or (negative? lseg) (REL-BUK! lseg lblk-num)))))
  314.   ent)
  315.  
  316.  
  317. ;;; Special entry points for Jonathan to do non-B-tree stuff.
  318. ;;; Also now used in chain-scan.
  319.  
  320. (define (allocate-ent)
  321.   (define ent (try-get-free-ent -1 -1))
  322.   (cond (ent
  323.      (ENT-SET-ACC! ent ACCWRITE)
  324.      (ENT-SET-DTY! ent #t)
  325.      (ENT-SET-PUS! ent 0)
  326.      (ENT-SET-SEG! ent -1)
  327.      (ENT-SET-ID! ent -1)
  328.      (ENT-SET-REF! ent 1)
  329.      (ENT-SET-NEXT! ent #f)
  330.      ent)
  331.     (else
  332.      (allocate-ent))))
  333.  
  334. (define (ent-copy! to-ent from-ent)
  335.   (if (not (eq? (ENT-ACC to-ent) ACCWRITE))
  336.       (fprintf diagout ">>>>ERROR<<<< ent-copy!: copying into non-ACCWRITE %d:%d\\n"
  337.            (ENT-SEG to-ent) (ENT-ID to-ent)))
  338.   (ENT-SET-SEG! to-ent (ENT-SEG from-ent))
  339.   (ENT-SET-ID! to-ent (ENT-ID from-ent))
  340.   (substring-move! (ENT-BLK from-ent) 0 (SEG-BSIZ (ENT-SEG from-ent)) (ENT-BLK to-ent) 0))
  341.  
  342. (define (get-ent-copy to-ent seg blk-num)
  343.   (define from-ent (get-ent seg blk-num ACCREAD))
  344.   (cond (from-ent
  345.      (ent-copy! to-ent from-ent)
  346.      (release-ent! from-ent ACCREAD)
  347.      #t)
  348.     (else #f)))
  349.  
  350. (define (write-ent-copy ent)
  351.   (define to-ent (get-ent (ent-seg ent) (ent-id ent) ACCWRITE))
  352.   (cond (to-ent
  353.      (ent-copy! to-ent ent)
  354.      (ENT-SET-DTY! to-ent #t)
  355.      (release-ent! to-ent ACCWRITE)
  356.      #t)
  357.     (else #f)))
  358.  
  359. ;;; End of Special entry points for Jonathan to do non-B-tree stuff.
  360.  
  361. ;;;; Stuff to deal with the free-list-cache (FLC)
  362.  
  363. (define (flush-flc! seg fullness)
  364.   (define fstr (make-string 4))
  365.   (define tstr (make-string 4))
  366.   (lck! (SEG-LCK seg))
  367.   (cond ((<= (SEG-FLC-LEN seg) fullness)
  368.      (unlck! (SEG-LCK seg)))
  369.     (else
  370.      (long2str! fstr 0 (vector-ref (SEG-FLC seg) (- (SEG-FLC-LEN seg) 1)))
  371.      (SEG-SET-FLC-LEN! seg (- (SEG-FLC-LEN seg) 1))
  372.      (unlck! (SEG-LCK seg))
  373. ;;;#|f|#     (fprintf diagout "flush-flc! %d:%d\\n" seg (str2long fstr 0))
  374.      (long2str! tstr 0 (get-universal-time))
  375.      (bt-put (SEG-FL-HAN seg) fstr 4 tstr 4) ;TBD check for error
  376.      (flush-flc! seg fullness))))
  377.  
  378. ;;; Assumes that SEG-LCK is locked by this process
  379.  
  380. (define (initload-flc? seg)
  381.   (case (SEG-FLC-LEN seg)
  382.     ((-1) (let* ((tmp-str (make-string 20))
  383.          (flc-image-len (bt-get (SEG-RT-HAN seg) "FLC" 3 tmp-str)))
  384.         (if (negative? flc-image-len) (set! flc-image-len 0)) ;TBD ??
  385.         (bt-put (SEG-RT-HAN seg) "FLC" 3 "" 0)
  386.         (SEG-SET-FLC-LEN! seg (quotient flc-image-len 4))
  387.         (do ((i (+ -4 flc-image-len) (+ -4 i)))
  388.         ((negative? i))
  389. ;;;         (fprintf diagout "%d %ld\n" i (str2long tmp-str i))
  390.           (vector-set! (SEG-FLC seg) (quotient i 4) (str2long tmp-str i))))
  391.       #t)
  392.     ((-2) (fprintf diagout
  393.            ">>>>ERROR<<<< initload-flc! on read only segment %d?\\n" seg)
  394.       #f)
  395.     (else #t)))
  396.  
  397. (define (blk-free ent)
  398.   (define seg (ENT-SEG ent))
  399. ;;;#|f|#  (fprintf diagout "blk-free %d:%d\\n" seg (ENT-ID ent))
  400.   (cond ((not (eq? (ENT-ACC ent) ACCWRITE))
  401.      (fprintf diagout ">>>>ERROR<<<<blk-free: %d:%ld without ACCWRITE\\n"
  402.           (ENT-SEG ent) (ENT-ID ent))
  403.      #f)
  404.     (else
  405.      (lck! (SEG-LCK seg))
  406.      (cond
  407.       ((not (initload-flc? seg)) (unlck! (SEG-LCK seg)) #f)
  408.       ((>= (SEG-FLC-LEN seg) (- FLC-LEN 1))
  409.        (unlck! (SEG-LCK seg))
  410.        (flush-flc! seg (- FLC-LEN 2))
  411.        (blk-free ent))
  412.       (else
  413.        (vector-set! (SEG-FLC seg) (SEG-FLC-LEN seg) (ENT-ID ent))
  414.        (SEG-SET-FLC-LEN! seg (+ (SEG-FLC-LEN seg) 1))
  415.        (amnesia-ent! ent)        ;renumber entry to seg -1
  416.        (unlck! (SEG-LCK seg))
  417.        #t)))))
  418.  
  419. (define (flc-fill seg)
  420.   (define fstr (make-string 4))
  421.   (define flen #f)
  422. ;;;#|f|#  (fprintf diagout "flc-fill %d\\n" (SEG-FLC-LEN seg))
  423.   (lck! (SEG-LCK seg))
  424.   (cond ((>= (SEG-FLC-LEN seg) 1)
  425.      (unlck! (SEG-LCK seg)) SUCCESS)    ;FLC has some blks in it.
  426.     ((not (try-lck (SEG-FCK seg)))         ; prevent multiple fillers
  427.      (unlck! (SEG-LCK seg))
  428.      (fprintf diagout
  429.           ">>>>WARNING<<<< Failed to get FLCK-- branch never tried before! Segment %d %s\\n"
  430.           seg (SEG-STR seg))
  431.      RETRYERR)
  432.     ((begin
  433.        (set! flen (bt-next (SEG-FL-HAN seg) "" 0 fstr))
  434.        (err? flen))            ;No blks left in free-list
  435.      (lck! empty-blk-lck)
  436.      (let ((xnum (+ (SEG-USED seg) (quotient FLC-LEN 2))))
  437.        (init-leaf-blk! empty-blk xnum IND-TYP)
  438.        (cond ((extend-file (SEG-PORT seg) empty-blk (SEG-BSIZ seg) xnum)
  439.           (if io-diag
  440.              (fprintf diagout
  441.                ">>>>EXTENDING<<<<  Segment %d %s by %d blocks.\\n"
  442.                seg (SEG-STR seg) (quotient FLC-LEN 2)))
  443.           (do ((i 0 (+ i 1)))
  444.               ((> i (quotient FLC-LEN 2))) ;this is actually + 1.
  445.             (vector-set! (SEG-FLC seg) (SEG-FLC-LEN seg) (- xnum i))
  446.             ;;reverse order so blks are allocated in order
  447.             (SEG-SET-FLC-LEN! seg (+ (SEG-FLC-LEN seg) 1))
  448.             (SEG-SET-USED! seg (+ (SEG-USED seg) 1)))
  449.           (let ((used-str (make-string 4))) ; This put should not cause a split!
  450.             (long2str! used-str 0 (SEG-USED seg))
  451.             (bt-put (SEG-RT-HAN seg) "USED" 4 used-str 4))
  452.           (unlck! empty-blk-lck)
  453.           (unlck! (SEG-LCK seg))
  454.           (unlck! (SEG-FCK seg))
  455.           SUCCESS)
  456.          (else
  457.           (fprintf diagout
  458.                ">>>>ERROR<<<< No more file space available! Segment %d %s\\n"
  459.                seg (SEG-STR seg))
  460.           (unlck! empty-blk-lck)
  461.           (unlck! (SEG-LCK seg))
  462.           (unlck! (SEG-FCK seg))
  463.           NOROOM))))
  464.     (else
  465.      (unlck! (SEG-LCK seg))
  466.      (let ((long-ara (make-vector (+ FLC-LEN 1)))
  467.            (xstr (make-string 256))
  468.            (respkt (make-vector PKT-SIZE))
  469.            (result SUCCESS))
  470.        (substring-move! fstr 0 flen xstr 0)
  471.        (vector-set! long-ara 0 0)    ; data count
  472.        (SET-SKEY-COUNT! respkt 0)
  473.        (set! result (bt-scan (SEG-FL-HAN seg) REM-SCAN xstr flen
  474.                  "" END-OF-CHAIN flc-proc long-ara respkt 1))
  475.        (cond ((or (= result SUCCESS) (= result NOTPRES) (= result TERMINATED))
  476. ;;;#|f|#          (fprintf diagout "FLC-FILL: %d blks fetched from free list \\n" (vector-ref long-ara 0))
  477.           (lck! (SEG-LCK seg))        ;successful remove from free-list
  478.           (do ((i (vector-ref long-ara 0) (- i 1)))
  479.               ((<= i 0))
  480.             (vector-set! (SEG-FLC seg) (SEG-FLC-LEN seg)
  481.                  (vector-ref long-ara i))
  482. ;;;            (fprintf diagout "FLC-FILL: put block %d into FLC \\n" (vector-ref long-ara i))
  483.             (SEG-SET-FLC-LEN! seg (+ (SEG-FLC-LEN seg) 1)))
  484.           (unlck! (SEG-LCK seg))
  485.           (unlck! (SEG-FCK seg))
  486.           SUCCESS)
  487.          (else
  488.           (unlck! (SEG-FCK seg))
  489.           result))))))
  490.  
  491. (define (flc-proc keystr klen vstr vlen long-ara)
  492.   (let ((ct (vector-ref long-ara 0)))
  493.     (if (< ct (quotient FLC-LEN 2))
  494.     (let ((num (str2long keystr 0)))
  495.       (set! ct (+ ct 1))
  496. ;;;      (fprintf diagout "FLC-PROC: got block %d ct=%d from freelist \\n" num ct)
  497.       (vector-set! long-ara 0 ct)
  498.       (vector-set! long-ara ct num)
  499.       SUCCESS)
  500.     TERMINATED)))
  501.  
  502. ;;;create-new-blk-ent leaves you with write access to blk
  503. (define (create-new-blk-ent seg)
  504. ;;;#|f|#  (fprintf diagout "create-new-blk-ent\\n")
  505.   (lck! (SEG-LCK seg))
  506.   (cond ((not (initload-flc? seg)) (unlck! (SEG-LCK seg)) #f)
  507.     ((<= (SEG-FLC-LEN seg) 0)
  508.      (unlck! (SEG-LCK seg))
  509.      (let ((res (flc-fill seg)))
  510.        (cond ((realerr? res) #f)
  511.          (else (create-new-blk-ent seg)))))
  512.     (else
  513.      (SEG-SET-FLC-LEN! seg (- (SEG-FLC-LEN seg) 1))
  514.      (let ((bnum (vector-ref (SEG-FLC seg) (SEG-FLC-LEN seg))))
  515.        (unlck! (SEG-LCK seg))
  516.        (get-ent seg bnum ACCWRITE))))) ;no read is done here.
  517. ;;; End of stuff to deal with the free-list-cache (FLC)
  518.  
  519. ;;; try-get-ent returns an entry with access or #f if blk is lcked.  When
  520. ;;; you are done with the entry you need to release-ent!.
  521. (define (try-get-ent seg blk-num acctype)
  522. ;;;  (fprintf diagout "try-get-ent %d:%ld %d\\n" seg blk-num acctype)
  523.   (let ((buk (GET-BUK-WAIT seg blk-num)))
  524.     (let entloop ((ent buk))
  525.       (cond
  526.        ((not ent)
  527.     (REL-BUK! seg blk-num)
  528.     (set! tge-fct (+ 1 tge-fct))
  529.     #f)
  530.        ((not (and (= seg (ENT-SEG ent)) (= blk-num (ENT-ID ent)))) ;chain through buk
  531.     (entloop (ENT-NEXT ent)))
  532.        ((not (= (BLK-ID (ENT-BLK ent)) blk-num))
  533.     (REL-BUK! seg blk-num)
  534.     (fprintf diagout ">>>>ERROR<<<< corrupted buffer %d:%ld <> %ld\\n"
  535.          (ENT-SEG ent) (BLK-ID (ENT-BLK ent)) blk-num)
  536.     (set! tge-fct (+ 1 tge-fct))
  537.     #f)
  538.        ((not acctype)            ; only asking NAME access
  539.     (ENT-SET-REF! ent (+ 1 (ENT-REF ent)))
  540.     (REL-BUK! seg blk-num)
  541.     (set! tge-ct (+ 1 tge-ct))
  542.     ent)
  543.        ((not (ENT-ACC ent))        ; entry not lcked
  544.     (ENT-SET-ACC! ent acctype)
  545. ;;;    (if (eq? acctype ACCWRITE) (ENT-SET-DTY! ent #t))
  546.     (ENT-SET-REF! ent (+ 1 (ENT-REF ent)))
  547.     (REL-BUK! seg blk-num)
  548.     (set! tge-ct (+ 1 tge-ct))
  549.     ent)
  550.        (else                ; entry not available
  551.     (REL-BUK! seg blk-num)
  552.     (set! tge-fct (+ 1 tge-fct))
  553.     #f)))))
  554.  
  555. (define (chain-find-ent han acctype key-str k-len pkt)
  556.   (define ent
  557.     (if (and cache-ent-enable (HAN-LAST han))
  558.     (try-get-ent (HAN-SEG han) (HAN-LAST han) acctype)
  559.     #f))
  560.   (if (and ent
  561.        (LEAF? (ENT-BLK ent))
  562.        (= (BLK-TOP-ID (ENT-BLK ent)) (HAN-ID han))
  563.        (blk-find-pos (ENT-BLK ent) key-str k-len pkt)
  564.        (or (eq? (MATCH-TYPE pkt) MATCH)
  565.            (and (or (eq? (MATCH-TYPE pkt) PASTP)
  566.             (eq? (MATCH-TYPE pkt) QPASTP))
  567.             (> (MATCH-POS pkt) BLK-DATA-START))))
  568.       (begin
  569. ;;;    (fprintf diagout "chain-find-ent: returned blk %d:%ld\\n" (ENT-SEG ent) (ENT-ID ent))
  570.     (set! tce-ct (+ tce-ct 1))
  571.     ent)
  572.       (begin
  573.     (if ent (release-ent! ent acctype))
  574.     (set! tce-fct (+ tce-fct 1))
  575.     (set! ent (get-ent (HAN-SEG han) (HAN-ID han) #f))
  576.     (cond ((or (not (root? (ENT-BLK ent))) (BLK-TYP? (ENT-BLK ent) SEQ-TYP))
  577.            (fprintf diagout ">>>>ERROR<<<<BT-OPEN: not a B-tree root %d:%d\\n"
  578.             (ENT-SEG ent) (ENT-ID ent))
  579.            (release-ent! ent #f)
  580.            (set! ent #f))
  581.           (else
  582.            (set! ent (find-ent ent LEAF -1 key-str k-len))))
  583.     (cond ((not ent) #f)
  584.           ((eq? acctype ACCREAD) #f)
  585.           ((ent-update-access ent ACCREAD acctype))
  586.           (else (release-ent! ent ACCREAD)
  587.             (set! ent #f)))
  588.     (if ent (set! ent (chain-find ent acctype key-str k-len pkt)))
  589.     (and ent (HAN-SET-LAST! han (ENT-ID ent)))
  590.     ent)))
  591.  
  592. ; I havent put the call to PREV-K-ENT inside here,
  593. ; as both paths need to call it - rjz
  594.  
  595. (define (chain-find-prev-ent han acctype key-str k-len pkt)
  596.   (define ent
  597.     (if (and cache-ent-enable (HAN-LAST han))
  598.     (try-get-ent (HAN-SEG han) (HAN-LAST han) acctype)
  599.     #f))
  600.   (if (and ent
  601.        (LEAF? (ENT-BLK ent))
  602.        (= (BLK-TOP-ID (ENT-BLK ent)) (HAN-ID han))
  603.        (blk-find-pos (ENT-BLK ent) key-str k-len pkt)
  604.        (or (eq? (MATCH-TYPE pkt) MATCH)
  605.            (eq? (MATCH-TYPE pkt) MATCHEND)
  606.            (and (or (eq? (MATCH-TYPE pkt) PASTP)
  607.             (eq? (MATCH-TYPE pkt) QPASTP))
  608.             (> (MATCH-POS pkt) BLK-DATA-START))))
  609.       (begin
  610. ;;;    (fprintf diagout "chain-find-prev-ent: returned blk %d:%ld\\n" (ENT-SEG ent) (ENT-ID ent))
  611.     (set! tce-ct (+ tce-ct 1))
  612.     ent)
  613.       (begin
  614.     (if ent (release-ent! ent acctype))
  615.     (set! tce-fct (+ tce-fct 1))
  616.     (set! ent (find-prev-ent (get-ent (HAN-SEG han) (HAN-ID han) #f)
  617.                 LEAF -1 key-str k-len))
  618.     (cond ((not ent) #f)
  619.           ((eq? acctype ACCREAD) #f)
  620.           ((ent-update-access ent ACCREAD acctype))
  621.           (else (release-ent! ent ACCREAD)
  622.             (set! ent #f)))
  623. ;;;    (if ent (set! ent (prev-k-ent ent key-str k-len LEAF pkt)))
  624.     ent)))
  625.  
  626. ;(REL-BUK! seg blk-num)
  627. ;(fprintf diagout ">>>>ERROR<<<< all ents in use!\\n")
  628.  
  629. (define (get-ent seg blk-num acctype)
  630. ;  (fprintf diagout "get-ent %d:%ld %d\\n" seg blk-num acctype)
  631.   (cond
  632.    ((negative? blk-num)
  633.     (fprintf diagout ">>>>ERROR<<<< negative block number %ld\\n" blk-num) #f)
  634.    ((>= blk-num (SEG-USED seg))
  635.     (fprintf diagout ">>>>ERROR<<<< bad block number %ld\\n" blk-num) #f)
  636.    (else
  637.     (let entloop ((ent (GET-BUK-WAIT seg blk-num)))
  638.       (cond
  639.        ((not ent)            ;not here; get from disk
  640.     (set! ent (try-get-free-ent seg blk-num))
  641.     (cond
  642.      (ent
  643.       (ENT-SET-NEXT! ent (GET-BUK seg blk-num))
  644.       (SET-BUK! seg blk-num ent)
  645.       (ENT-SET-ACC! ent ACCPEND)
  646.       (ENT-SET-SEG! ent seg)
  647.       (ENT-SET-ID! ent blk-num)
  648.       (ENT-SET-AGE! ent -127)    ;not looked at till release-ent!
  649.       (ENT-SET-DTY! ent #f)
  650.       (ENT-SET-PUS! ent 0)
  651.       (ENT-SET-REF! ent 1)
  652.       (REL-BUK! seg blk-num)
  653.       ;;        (fprintf diagout "Reading block %d:%ld\\n" seg blk-num)
  654.       (cond
  655.        ((eq? acctype ACCWRITE)
  656.         (ENT-SET-ACC! ent ACCWRITE)
  657.         (ENT-SET-DTY! ent #t)
  658.         (init-leaf-blk! (ENT-BLK ent) blk-num IND-TYP)
  659.         (set! ge-ct (+ 1 ge-ct))
  660.         ent)
  661.        ((blk-read (SEG-PORT seg) (ENT-BLK ent) (SEG-BSIZ seg) blk-num)
  662.         (ENT-SET-ACC! ent acctype)    ;lines before here don't need to lck buk
  663.         (if (not (= (BLK-ID (ENT-BLK ent)) blk-num))
  664.         (fprintf diagout ">>>>ERROR<<<< corrupted blk %d:%ld <> %ld\\n"
  665.              (ENT-SEG ent) blk-num (BLK-ID (ENT-BLK ent))))
  666.         (set! ge-ct (+ 1 ge-ct))
  667.         ent)
  668.        (else            ;read not successful; errmsg in blk-read
  669.         (ENT-SET-REF! ent 0)
  670.         (ENT-SET-ACC! ent #f)
  671.         (set! ge-fct (+ 1 ge-fct))
  672.         #f)))
  673.      (else (entloop (GET-BUK-WAIT seg blk-num))))) ; try again
  674.        ((not (and (= seg (ENT-SEG ent)) (= blk-num (ENT-ID ent)))) ;chain through buk
  675.     (entloop (ENT-NEXT ent)))
  676.        ((not (= (BLK-ID (ENT-BLK ent)) blk-num))
  677.     (REL-BUK! seg blk-num)
  678.     (fprintf diagout ">>>>ERROR<<<< corrupted buffer %d:%ld <> %ld\\n"
  679.          (ENT-SEG ent) (BLK-ID (ENT-BLK ent)) blk-num)
  680.     (set! ge-fct (+ 1 ge-fct))
  681.     #f)
  682.        ((not acctype)            ; only asking NAME access
  683.     (ENT-SET-REF! ent (+ 1 (ENT-REF ent)))
  684.     (REL-BUK! seg blk-num)
  685.     (set! ge-ct (+ 1 ge-ct))
  686.     ent)
  687.        ((not (ENT-ACC ent))        ; entry not lcked
  688.     (ENT-SET-ACC! ent acctype)
  689. ;;;      (if (eq? acctype ACCWRITE) (ENT-SET-DTY! ent #t))
  690.     (ENT-SET-REF! ent (+ 1 (ENT-REF ent)))
  691.     (REL-BUK! seg blk-num)
  692.     (set! ge-ct (+ 1 ge-ct))
  693.     ent)
  694.        (else                ; entry not available
  695.     (REL-BUK! seg blk-num)
  696.     (set! ge-fct (+ 1 ge-fct))
  697.     #f))))))
  698.  
  699. (define (switch-ent old-ent oldacc new-num newacc)
  700. ;;;  (fprintf diagout "switch-ent %d:%ld %d %d %d\\n"
  701. ;;;       (ENT-SEG old-ent) (ENT-ID old-ent) oldacc new-num newacc)
  702.   (let ((new-ent (get-ent (ENT-SEG old-ent) new-num #f)))
  703.     (release-ent! old-ent oldacc)
  704.     (if new-ent (ent-update-access new-ent #f newacc)) ;doesn't check that access changed
  705.     new-ent))
  706.  
  707. ;;;minimum real NUM-ENTS-CT is 12*number of processes
  708. ;;;minimum NUM-BUKS IS 2, MAYBE 3 (due to how get-free-ent works)
  709. ;;;minimum real BLK-SIZE is 1.5K
  710.  
  711. (define (init-wb MAX-NUM-ENTS-CT MAX-NUM-BUKS MAX-BLK-SIZE)
  712.   (cond
  713.    (free-ent-lck
  714.     (fprintf diagout ">>>>ERROR<<<< init-wb: already initialized\\n")
  715.     ARGERR)
  716.    (else
  717.     (set! diagout stdout)
  718.     (fprintf diagout "        Initializing %s.\\n" db-version-str)
  719.     (fprintf diagout "        Copyright (C) 1991, 1992, 1993 Holland Mark Martin.\\n")
  720.     (fprintf diagout "        See file README for terms applying to this program.\\n")
  721.     (clear-stats)
  722.     (set! num-buks MAX-NUM-BUKS)
  723.     (set! blk-size MAX-BLK-SIZE)
  724.     (set! empty-blk (make-string blk-size))
  725.     (set! empty-blk-lck (make-lck -3))
  726.     (set! free-buk-cntr 0)
  727.     (set! free-ent-lck (make-lck -1))
  728.     (set! flush-buk-cntr 0)
  729.     (set! flush-buk-lck (make-lck -2))
  730.     (set! buk-tab (make-vector num-buks #f))
  731.     (set! lck-tab (make-vector num-buks #f))
  732.     (set! ent-tab (make-vector ENT-TAB-INC #f))
  733.     (do ((i num-buks (- i 1)))
  734.     ((zero? i))
  735.       (vector-set! lck-tab (- i 1) (make-lck (- i 1))))
  736.     (do ((seg 9 (- seg 1)))
  737.     ((negative? seg))
  738.       (lck! (SEG-LCK seg))
  739.       (SEG-SET-FLC! seg (make-vector FLC-LEN 0))
  740.       (SEG-SET-FLC-LEN! seg 0)
  741.       (unlck! (SEG-LCK seg)))
  742.     (lck! free-ent-lck)
  743.     (do ((i MAX-NUM-ENTS-CT (- i 1))
  744.      (bent #f))
  745.     ((zero? i) (set! free-ents bent))
  746.       (let ((newent (make-ent num-ents-ct)))
  747.     (cond (newent
  748.            (ENT-SET-NEXT! newent bent)
  749.            (set! bent newent)
  750.            (vector-set! ent-tab num-ents-ct newent)
  751.            (ENT-SET-TAG! newent num-ents-ct)
  752.            (set! num-ents-ct (+ 1 num-ents-ct))
  753.            (if (zero? (remainder num-ents-ct ENT-TAB-INC))
  754.            (let ((tmp-ent-tab
  755.               (vector-set-length! ent-tab
  756.                           (+ ENT-TAB-INC num-ents-ct))))
  757.              (if tmp-ent-tab (set! ent-tab tmp-ent-tab)
  758.              (set! i 1)))))
  759.           (else            ;no more memory - return
  760.            (set! i 1)))))
  761.     (unlck! free-ent-lck)
  762.     num-ents-ct)))
  763.  
  764. (define (final-wb)
  765.   (cond (free-ent-lck            ;make sure that init has happened.
  766.      (do ((seg 9 (- seg 1)))
  767.          ((negative? seg))
  768.        (if (not (seg-free? seg)) (close-seg seg #t)))
  769.      (lck! free-ent-lck)
  770.      (do ((i num-ents-ct (- i 1)))
  771.          ((zero? i))
  772.        (free! (vector-ref ent-tab (+ -1 i)))
  773.        (vector-set! ent-tab (+ -1 i) #f)
  774.        (set! num-ents-ct (+ -1 num-ents-ct)))
  775.      (unlck! free-ent-lck)
  776.      (do ((seg 9 (- seg 1)))
  777.          ((negative? seg))
  778.        (lck! (SEG-LCK seg))
  779.        (free! (SEG-FLC seg)) (SEG-SET-FLC! seg #f)
  780.        (SEG-SET-FLC-LEN! seg 0)
  781.        (unlck! (SEG-LCK seg)))
  782.      (do ((i num-buks (- i 1)))
  783.          ((zero? i))
  784.        (free! (vector-ref lck-tab (- i 1)))
  785.        (vector-set! lck-tab (- i 1) #f))
  786.      (free! ent-tab) (set! ent-tab #f)
  787.      (free! lck-tab) (set! lck-tab #f)
  788.      (free! buk-tab) (set! buk-tab #f)
  789.      (free! flush-buk-lck) (set! flush-buk-lck #f)
  790.      (free! free-ent-lck) (set! free-ent-lck #f)
  791.      (free! empty-blk) (set! empty-blk #f)
  792.      (free! empty-blk-lck) (set! empty-blk-lck #f)
  793.      SUCCESS)
  794.     (else ARGERR)))
  795.  
  796. (define (check-blk! blk)
  797.   (let ((b-end (BLK-END blk)))
  798.     (let lp ((b-pos BLK-DATA-START))
  799.       (let ((s-pos (next-field blk (+ 1 b-pos))))
  800.     (cond
  801.      ((= s-pos b-end) #f)
  802.      ((< s-pos b-end) (lp (next-cnvpair blk b-pos)))
  803.      (else
  804.       (fprintf diagout ">>>>ERROR<<<< check-blk!: blk %d past end %d\\n"
  805.            (BLK-ID blk) s-pos)
  806.       #f))))))
  807.  
  808. (define (check-key-order! blk)
  809.   (define split-str (make-string 256))
  810.   (define spos (split-key-pos blk))
  811.   (and spos (recon-this-key blk spos split-str 0 256)))
  812.  
  813. (define (do-seg-buffers seg func)
  814.   (let lp ((i num-buks) (ent #f))    ;was (ent free-ents)
  815.     (cond ((not ent)
  816.        (if (zero? i) SUCCESS
  817.            (lp (- i 1) (vector-ref buk-tab (- i 1)))))
  818.       ((or (negative? seg) (eq? seg (ENT-SEG ent)))
  819.        (let ((ans (func ent)))
  820.          (if (success? ans)
  821.          (lp i (ENT-NEXT ent))
  822.          ans)))
  823.       (else (lp i (ENT-NEXT ent))))))
  824.  
  825. (define (check-buffer ent)
  826.   (cond ((not (zero? (ENT-REF ent)))
  827.      ;(and (not (zero? (ENT-ID ent))))
  828.      (fprintf diagout ">>>>ERROR<<<<   Entry still referenced: %d:%ld\\n"
  829.           (ENT-SEG ent) (ENT-ID ent))
  830.      (ENT-SET-REF! ent 0)))
  831.   (cond ((ENT-ACC ent)
  832.      (fprintf diagout ">>>>ERROR<<<<   Entry still lcked: %d:%ld\\n"
  833.           (ENT-SEG ent) (ENT-ID ent))
  834.      (ent-update-access ent (ENT-ACC ent) #f)))
  835.   SUCCESS)
  836.  
  837. (define (check-access!)
  838.   (flush-some-buks 1 5) ;TBD remove when flush works on alarm int.
  839.   (check-lcks)
  840.   (do-seg-buffers -1 check-buffer))
  841.  
  842. ;;; This routine needs to deal with lck issues.
  843. ;;; TBD needs to give error if lcked.
  844. (define (flush-buffer ent)
  845.   (cond ((ENT-ACC ent) TERMINATED)
  846.     ((ENT-DTY? ent) (if (ent-write ent) SUCCESS RETRYERR))
  847.     (else SUCCESS)))
  848.  
  849. (define (purge-buffer ent)
  850.   (cond ((ENT-DTY? ent)
  851.      (if (or (eq? (ENT-ACC ent) ACCWRITE)
  852.          (eq? (ENT-ACC ent) ACCPEND))
  853.          (fprintf diagout "  Purging %s entry: %d:%ld\\n"
  854.               (if (eq? (ENT-ACC ent) ACCWRITE) "ACCWRITE" "ACCPEND")
  855.               (ENT-SEG ent) (ENT-ID ent)))
  856.      (ent-write ent)))
  857.   (amnesia-ent! ent)
  858.   SUCCESS)
  859.